home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TURBOK50.LZH / SOURCE.ARC / LISTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-06-02  |  16KB  |  442 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.01a                             }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  ListTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {Update History:     5.01a   Removed refrences to VER50 and added DEBUG
  18.                              compiler directive, added Mouse enter
  19. }
  20.  
  21. {$S-,R-,V-}
  22. {$IFNDEF DEBUG}
  23. {$D-}
  24. {$ENDIF}
  25.  
  26. Unit ListTTT5;
  27.  
  28. interface
  29.  
  30. Uses CRT, DOS, FastTTT5, WinTTT5, KeyTTT5, StrnTTT5;
  31.  
  32. const
  33.      Max_Topics = 255;
  34.  
  35. Type
  36.    Choices = array[1..Max_Topics] of boolean;
  37.    {$IFNDEF VER40}
  38.     List_Hook = Procedure(var Ch: char; HiPick:byte);
  39.    {$ENDIF}
  40.    L_Display = record
  41.                      X           : byte;             {top X coord}
  42.                      Y           : byte;             {top Y coord}
  43.                      LeftSide    : Boolean;          {X,Y is leftside of box}
  44.                      Lines       : byte;             {max no of lines to display in box}
  45.                      TopicWidth  : byte;             {width of the slection bar}
  46.                      AllowEsc    : boolean;          {allow the user to escape?}
  47.                      BoxType     : byte;             {single,double etc}
  48.                      BoxFCol     : byte;             {Border foreground color}
  49.                      BoxBCol     : byte;             {Border background color}
  50.                      CapFCol     : byte;             {Capital letter foreground color}
  51.                      BacCol      : byte;             {menu background color}
  52.                      NorFCol     : byte;             {normal foreground color}
  53.                      HiFCol      : byte;             {highlighted topic foreground color}
  54.                      HiBCol      : byte;             {highlighted topic background color}
  55.                      LeftChar    : char;             {left-hand topic highlight character}
  56.                      RightChar   : char;             {right-hand topic highlight character}
  57.                      ToggleChar  : char;             {indicates if a topic has been selected}
  58.                      AllowToggle : Boolean;          {can user select more than one topic}
  59.                      End_Chars   : set of char;      {end of input chars}
  60.                      Select_Chars: set of char;      {keys for user to select topic}
  61.                      {$IFNDEF VER40}
  62.                      Hook: List_Hook; {a procedure called after every key is pressed}
  63.                      {$ENDIF}
  64.                end;
  65.  
  66. Var
  67.    LTTT    : L_Display;
  68.    L_Picks : Choices;
  69.    L_Char  : Char;
  70.    L_Pick  : Byte;
  71.    {$IFDEF VER40}
  72.    L_UserHook  : pointer;
  73.    {$ENDIF}
  74.  
  75. Procedure Default_Settings;
  76. Procedure Show_List(var StrArray;StrLength:Byte;TotalPicks:byte);
  77.  
  78. IMPLEMENTATION
  79. const
  80.     Default_Display_Lines = 10;
  81.     Default_Y1            = 7;
  82.  
  83.   {$IFNDEF VER40}
  84.   {$F+}
  85.   Procedure No_Hook(var Ch: char; HiPick :byte);
  86.   {}
  87.   begin
  88.   end; {of proc No_Hook}
  89.   {$F-}
  90.   {$ENDIF}
  91.  
  92.   Procedure Default_Settings;
  93.   begin
  94.       with LTTT do
  95.       begin
  96.           AlloWEsc := true;
  97.           X := 0;
  98.           Y := 0;
  99.           LeftSide := true;
  100.           BoxType      := 1;
  101.           Lines := 0;
  102.           TopicWidth   := 0;
  103.           If BaseOfScreen = $B800 then
  104.           begin
  105.               BoxFCol      := yellow;
  106.               BoxBCol      := blue;
  107.               CapFCol      := White;
  108.               BacCol       := blue;
  109.               NorFCol      := lightgray;
  110.               HiFCol       := white;
  111.               HiBCol       := red;
  112.           end
  113.           else
  114.           begin
  115.               BoxFCol      := white;
  116.               BoxBCol      := black;
  117.               CapFCol      := White;
  118.               BacCol       := black;
  119.               NorFCol      := lightgray;
  120.               HiFCol       := white;
  121.               HiBCol       := black;
  122.           end;
  123.           LeftChar     := Chr(16);
  124.           RightChar    := Chr(17);
  125.           ToggleChar   := Chr(251);
  126.           AllowToggle  := true;
  127.           End_Chars    := [#13,#133];
  128.           Select_Chars := [' '];
  129.           {$IFNDEF VER40}
  130.           Hook := No_Hook;
  131.           {$ELSE}
  132.           L_UserHook := nil;
  133.           {$ENDIF}
  134.       end;  {with}
  135.   end;  {Default_Settings}
  136.  
  137.   {$IFDEF VER40}
  138.    Procedure CallFromListUserHook(var Ch:char;Hipick:byte);
  139.              Inline($FF/$1E/L_UserHook);
  140.   {$ENDIF}
  141.  
  142.  Procedure Show_List(var StrArray;StrLength:Byte;TotalPicks:byte);
  143.  {}
  144.  var
  145.    X1,Y1,X2,Y2 : byte;
  146.    ListWidth   : byte;
  147.    ListLines   : byte;
  148.    TopPick     : byte;
  149.    HiPick      : byte;
  150.    Selected    : Choices;
  151.    Finished    : boolean;
  152.    Scrolling   : boolean;
  153.    ChL         : char;
  154.  
  155.          Function TopicStr(StrNo:byte): StrScreen;
  156.          {searches through string array and returns the string}
  157.          var
  158.            W : word;
  159.            TempStr : String;
  160.            ArrayOffset: word;
  161.          begin
  162.              W := pred(StrNo) * succ(StrLength);
  163.              ArrayOffset := Ofs(StrArray) + W;
  164.              Move(Mem[Seg(StrArray):ArrayOffset],TempStr,1);            {string length in byte 0}
  165.              Move(Mem[Seg(StrArray):succ(ArrayOffset)],TempStr[1],ord(TempStr[0]));
  166.              TopicStr := TempStr;
  167.          end; {of func TopicStr}
  168.  
  169.          Procedure Write_Topic(TopicNo:word;Hilight:boolean);
  170.          {}
  171.          var
  172.            A, Y : byte;
  173.            Tick : char;
  174.          begin
  175.              Y := Succ(Y1) + TopicNo - TopPick;
  176.              If Selected[TopicNo] then
  177.                 Tick := LTTT.ToggleChar
  178.              else
  179.                 Tick := ' ';
  180.              If HiLight then
  181.                 Fastwrite(succ(X1),Y,
  182.                           attr(LTTT.HiFCol,LTTT.HiBCol),
  183.                           LTTT.LeftChar+Tick+' '+padleft(TopicStr(TopicNo),ListWidth,' ')+LTTT.RightChar)
  184.              else
  185.                 Fastwrite(succ(X1),Y,
  186.                           attr(LTTT.NorFCol,LTTT.BacCol),
  187.                           ' '+Tick+' '+padleft(TopicStr(TopicNo),ListWidth,' ')+' ');
  188.          end; {of proc Write_Topic}
  189.  
  190.          Procedure Compute_Topic_Width;
  191.          {}
  192.          var
  193.            I : word;
  194.            W : Byte;
  195.          begin
  196.              ListWidth := 0;
  197.              For I := 1 To TotalPicks do
  198.              begin
  199.                  W := length(TopicStr(I));
  200.                  If ListWidth < W then
  201.                     ListWidth := W;
  202.              end;
  203.              Inc(ListWidth);  {add one char space to right}
  204.          end; {of proc Compute_Topic_Width}
  205.  
  206.          Procedure Compute_Coords;
  207.          {determines the X Y coords of the list box}
  208.          begin
  209.              With LTTT do
  210.              begin
  211.                  If TopicWidth <> 0 then
  212.                     ListWidth := TopicWidth
  213.                  else
  214.                     Compute_Topic_Width;
  215.                  ListWidth := ListWidth + 6;
  216.                  If Lines <> 0 then
  217.                     ListLines := Lines
  218.                  else
  219.                     ListLines := Default_Display_Lines;
  220.                  If ListLines > TotalPicks then
  221.                     ListLines := TotalPicks;
  222.                  If X <> 0 then
  223.                  begin
  224.                      If LeftSide then
  225.                      begin
  226.                          X1 := X;
  227.                          X2 := X1 + Pred(ListWidth);
  228.                      end
  229.                      else
  230.                      begin
  231.                          X2 := X;
  232.                          X1 := X2 - pred(ListWidth);
  233.                      end;
  234.                  end
  235.                  else
  236.                  begin
  237.                      X1 :=  (80 - ListWidth) div 2;
  238.                      X2 :=   X1 + Pred(ListWidth);
  239.                  end;
  240.                  If Y <> 0 then
  241.                      Y1 := Y
  242.                  else
  243.                      Y1 := Default_Y1;
  244.                  If Y1 + succ(ListLines) > DisplayLines then
  245.                  begin
  246.                      Y2 := DisplayLines;
  247.                      ListLines := Y2 - succ(Y1);
  248.                  end
  249.                  else
  250.                      Y2 :=  Y1 + Succ(ListLines);
  251.                  ListWidth := ListWidth - 6;    {set to actual topic width}
  252.                  If ListLines < TotalPicks then
  253.                     Scrolling := true
  254.                  else
  255.                     Scrolling := false;
  256.              end;  {with LTTT}
  257.          end; {of proc Compute_Coords}
  258.  
  259.          Procedure Draw_List_Box;
  260.          {}
  261.          begin
  262.              with LTTT do
  263.              begin
  264.                  Box(X1,Y1,X2,Y2,BoxFCol,BoxBCol,BoxType);
  265.                  ClearText(succ(X1),Succ(Y1),Pred(X2),Pred(Y2),NorFcol,BacCol);
  266.              end; {with}
  267.          end; {of proc Draw_List_Box}
  268.  
  269.          Procedure Set_Parameters;
  270.          {}
  271.          var I : integer;
  272.          begin
  273.              For I := 1 to Max_Topics do
  274.                  Selected[I] := false;
  275.              TopPick := 1;
  276.              HiPick := 1;
  277.          end; {of proc Set_Parameters}
  278.  
  279.          Procedure Display_More;
  280.          {}
  281.          var A : byte;
  282.          begin
  283.              If Scrolling then
  284.              begin
  285.                     A := attr(LTTT.BoxFCol,LTTT.BoxBCol);
  286.                     If TopPick > 1 then
  287.                        Fastwrite(X2,Succ(Y1),A,chr(24))
  288.                     else
  289.                        VertLine(X2,Succ(Y1),Succ(Y1),LTTT.BoxFcol,LTTT.BoxBCol,Lttt.Boxtype);
  290.                     If TopPick + Pred(ListLines) < TotalPicks then
  291.                        Fastwrite(X2,Pred(Y2),A,chr(25))
  292.                     else
  293.                        VertLine(X2,Pred(Y2),Pred(Y2),LTTT.BoxFcol,LTTT.BoxBCol,Lttt.Boxtype);
  294.              end;
  295.          end; {of proc Display_More}
  296.  
  297.          Procedure Display_All_Topics;
  298.          {}
  299.          var  I : Integer;
  300.          begin
  301.              For I := TopPick to TopPick+pred(ListLines) do
  302.                  Write_Topic(I,false);
  303.              Write_Topic(HiPick,True);
  304.              Display_More;
  305.          end; {of proc Display_All_Topics}
  306.  
  307.  begin
  308.      Set_Parameters;
  309.      Compute_Coords;
  310.      Draw_List_Box;
  311.      Display_All_Topics;
  312.      Finished := false;
  313.      Repeat
  314.           ChL := GetKey;
  315.           {$IFNDEF VER40}
  316.           LTTT.Hook(ChL,HiPick);
  317.           {$ELSE}
  318.           If L_UserHook <> nil then
  319.              CallFromListUserHook(ChL,HiPick);
  320.           {$ENDIF}
  321.           If ChL in LTTT.End_Chars then
  322.              Finished := true
  323.           else
  324.               If ChL <> #0 then
  325.               If (ChL in LTTT.Select_Chars) and LTTT.AllowToggle then
  326.               begin
  327.                    Selected[HiPick] := not Selected[HiPick];
  328.                    Write_Topic(HiPick,True);
  329.               end
  330.               else
  331.                  Case UpCase(ChL) of
  332.                  #132,
  333.                  #027: If LTTT.AllowEsc then       {Esc}
  334.                           Finished := True;
  335.                  #129,                             {Mouse_Down}
  336.                  #208: begin                       {Down_Arrow}
  337.                            Write_Topic(HiPick,False);
  338.                            If HiPick < TotalPicks then
  339.                               Inc(HiPick)
  340.                            else
  341.                               If (Scrolling = false) and (Chl <> #129) then
  342.                                  HiPick := 1;
  343.                            If HiPick > TopPick + Pred(ListLines) then
  344.                            begin
  345.                                Inc(TopPick);
  346.                                Display_All_Topics;
  347.                            end
  348.                            else
  349.                               Write_Topic(HiPick,True);
  350.                        end;
  351.                  #128,                             {Mouse_Up}
  352.                  #200: begin                       {Up_Arrow}
  353.                            Write_Topic(HiPick,False);
  354.                            If HiPick > 1 then
  355.                               Dec(HiPick)
  356.                            else
  357.                               If (Scrolling = false) and (Chl <> #128) then
  358.                                  HiPick := TotalPicks;
  359.                            If HiPick < TopPick then
  360.                            begin
  361.                                Dec(TopPick);
  362.                                Display_All_Topics;
  363.                            end
  364.                            else
  365.                               Write_Topic(HiPick,True);
  366.                        end;
  367.                  #199: If HiPick <> 1 then       {Home}
  368.                        begin
  369.                            HiPick := 1;
  370.                            TopPick := 1;
  371.                            Display_All_Topics;
  372.                        end;
  373.                  #207: If HiPick <> TotalPicks then   {end}
  374.                        begin
  375.                            HiPick := TotalPicks;
  376.                            TopPick := HiPick - pred(ListLines);
  377.                            Display_All_Topics;
  378.                        end;
  379.                  #201: If Scrolling then   {PgUp}
  380.                        begin
  381.                           If HiPick > ListLines then
  382.                           begin
  383.                              HiPick := HiPick - ListLines;
  384.                              If TopPick > ListLines then
  385.                                 TopPick := TopPick - ListLines
  386.                              else
  387.                                 TopPick := 1;
  388.                           end
  389.                           else
  390.                           begin
  391.                              HiPick := 1;
  392.                              TopPick := 1;
  393.                           end;
  394.                           Display_All_Topics;
  395.                       end
  396.                       else
  397.                       begin
  398.                           If HiPick > 1 then
  399.                           begin
  400.                               Write_Topic(HiPick,False);
  401.                               HiPick := 1;
  402.                               Write_Topic(HiPick,True);
  403.                           end;
  404.                       end;
  405.                  #209:If Scrolling then   {PgDn}
  406.                       begin
  407.                           If HiPick + ListLines <= TotalPicks then
  408.                           begin
  409.                              HiPick := HiPick + ListLines;
  410.                              If TopPick + ListLines +pred(ListLines) > TotalPicks then
  411.                                 TopPick := TotalPicks - pred(ListLines)
  412.                              else
  413.                                 TopPick := TopPick + ListLines;
  414.                           end
  415.                           else
  416.                           begin
  417.                              HiPick := TotalPicks;
  418.                              TopPick := TotalPicks - pred(ListLines);
  419.                           end;
  420.                           Display_All_Topics;
  421.                       end
  422.                       else
  423.                       begin
  424.                           If HiPick < TotalPicks then
  425.                           begin
  426.                               Write_Topic(HiPick,False);
  427.                               HiPick := TotalPicks;
  428.                               Write_Topic(HiPick,True);
  429.                           end;
  430.                       end;
  431.                  end;  {case}
  432.      Until Finished;
  433.      L_Char := ChL;
  434.      L_Picks := Selected;
  435.      L_Pick := HiPick;
  436.  end; {of proc Show_List}
  437.  
  438.  
  439. begin
  440.     Default_Settings;
  441. end.
  442.